#define IPRPAR_DEBUG -1
!
!  Dalton, a molecular electronic structure program
!  Copyright (C) The Dalton Authors (see AUTHORS file for details).
!
!  This program is free software; you can redistribute it and/or
!  modify it under the terms of the GNU Lesser General Public
!  License version 2.1 as published by the Free Software Foundation.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!  Lesser General Public License for more details.
!
!  If a copy of the GNU LGPL v2.1 was not distributed with this
!  code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html.
!
!
C
C FILE: dalpar.F
C
C (until Jan. 2017 these subroutines were in eri/eri2par.F)

C
C  /* Deck dalton_nodedriver */
#if defined (VAR_MPI)
      SUBROUTINE DALTON_NODEDRIVER(MWORK,WRKDLM)
C
C Slaves are sent to this nodedriver from abacus/dalton.F where they
C idle until the keyword IPRTYP is set with an MPI_BCAST (this is
C mediated via the subroutine MPIXBCAST from /gp/mpimacro.F)
C Once the slaves have received the IPRTYP.ne.0 broadcast, they need a
C broadcast with the print level.
C IPRTYP is set in iprtyp.h. This file associates every parallel
C computation in Dalton with an specific integer and a character string.
C This iprtyp.h file has to be imported in every subroutine that wants to
C communicate with this nodedriver.
C
C If you add a parallel routine to Dalton it needs to be added to
C iprtyp.h
C
C  This idling works because MPIXBCAST in a collective and blocking
C communication. Every slave will be blocked by the broadcast at label
C 100 until the master participates in the broadcast. As soon as an
C IPRTYP broadcast is made, every slave executes the computation
C associated with the broadcast once, exits the if-statement and is
C blocked/idles once again by the MPI_COMM_WORLD broadcast at label 100.
C
C If IPRTYP is set to 0 the nodes exit the loop.
C
C As of Aug 2013, you have to broadcast the IPRTYP from the master node
C using MPIXBCAST or MPI_BCAST, to communicate with the nodedriver.
C This mean you can change IPRTYP locally if you need it for whatever
C reason. To start a parallel calculation the master HAS to broadcast
C the IPRTYP and the needed parameters for the calculation.
C
C IMPORTANT: The communication is always via the communicator
C MPI_COMM_WORLD, so if another communicator is made, only those nodes
C included in the new communicator will receive the broadcast IPRTYP.
C This is because the nodedriver uses the MPIXBCAST subroutine to
C communicate and as of Nov 2014 this is hardcoded to MPI_COMM_WORLD.
C
#ifdef VAR_IFORT
!     subroutine sleep is in IFPORT module
      use IFPORT, ONLY: SLEEPQQ
#endif
#ifdef MOD_CGTO_DIFF_ERI
      use eri_basis_loops
#endif
      use so_parutils, only: soppa_nodedriver
      use pelib_interface, only: pelib_ifc_slave
      use qfitlib_interface, only: qfitlib_ifc_slave
#if defined (HAS_PCMSOLVER)
      use pcm_parallel, only: j1ints_pcm
#endif
      use parallel_models_mpi, only: lucita_models_enabled

#include "implicit.h"

#include "priunit.h"
#include "mtags.h"
C infpar.h: MASTER,MYNUM, PARHER
#include "maxorb.h"
#include "infpar.h"
C iprtyp.h: define parallel calculation types
#include "iprtyp.h"
#include "mpif.h"

C gnrinf.h : PARCAL, DIRCAL
#include "gnrinf.h"

      real(8), allocatable  :: work(:)
      integer(4), parameter :: TEN_4 = 10
      character(len=24)     :: fdate

! ======================================================

      CALL QENTER('DALTON_NODEDRIVER')
      CALL GETTIM(CSTR,WSTR)

      CALL TITLER('Starting in DALTON_NODEDRIVER',' ',200)
      WRITE(LUPRI,'(/A)')
     &      '(See DALTON/include/iprtyp.h for IPRTYP codes)'
      PARCAL = .TRUE.
      DIRCAL = .TRUE.
      PARHER = .TRUE.

      N_TASKS = 0
C
C     Get calculation type (IPRTYP)
  100 CONTINUE
      CALL MPIXBCAST(IPRTYP,1,'INTEGER',MASTER)
C
      IF (IPRTYP.GT.0) THEN
         N_TASKS = N_TASKS + 1

         CALL newTIMER('START')
         CALL MPIXBCAST(IPRINT,1,'INTEGER',MASTER)
         CALL newTIMER('waiting')

         CALL newTIMER('START')
#if defined (VAR_IFORT) || defined (VAR_GFORTRAN)
         write (lupri,'(/A,I5,A,I8,A,I5,A,I5,2A)')
     &      'Node',MYNUM,' received task',N_TASKS,' IPRTYP =',IPRTYP,
     &      ' Print level is',IPRINT,' Time is ',fdate()
#else
         write (lupri,'(/A,I5,A,I8,A,I5,A,I5)')
     &      'Node',MYNUM,' received task',N_TASKS,' IPRTYP =',IPRTYP,
     &      ' Print level is',IPRINT
#endif
         flush(lupri)

!        allocate memory here if we do not call hermit (more to follow...).
!        idea: move allocation down to main driver routines of modules as we might want to use
!              dynamic memory allocation down there (for MPI performance/MPI standard compliance reasons)
!              which is severely hampered by a "static" WORK for everything.
!              sknecht - feb 2013.
         if(iprtyp /= HER_WORK .and. .not.(allocated(work)))then
!          allocate memory using f90 utilities
           allocate(work(0:mwork+1),stat=i)
!          Set memory traps
           work(0)       = wrkdlm
           work(1+mwork) = wrkdlm

           if(i /= 0)then
             write (lupri,*) mynum,
     &        ': ALLOCATE command failed to allocate'//
     &        ' the requested memory ',mwork,' on slave. Error code:',i
             write (lupri,*)
     &        'Reduce the memory demands and be welcome back'
             call quit('Failed to allocate memory on slave')
           end if
         end if

C  new calculation type needs to be added in include/iprtyp.h
         IF      (IPRTYP.EQ.HER_WORK) THEN
            CALL HER_NODSTR(MWORK,wrkdlm,IPRINT)
         ELSE IF (IPRTYP.EQ.ERI_WORK) THEN
            CALL ERI_NODSTR(WORK(1),MWORK,IPRINT)
C        ELSE IF (IPRTYP.EQ.GEM_WORK) THEN
C           CALL GEMNOD(WORK(1),MWORK,MASTER,MYNUM,MYNUM,IPRINT)
         ELSE IF (IPRTYP.EQ.DFT_KSM_WORK) THEN
            CALL DFT_KSMSLAVE(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.DFT_C_WORK) THEN
            CALL DFT_CSLAVE(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.DFT_GRAD_WORK) THEN
            CALL DFT_GRAD_SLAVE(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.DFT_EXPGRAD_WORK) THEN
            CALL DFT_EXPG_SLAVE(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.DFT_BRHS_WORK) THEN
            CALL DFT_BRHS_SLAVE(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.DFT_HESSTAT_WORK) THEN
            CALL DFT_HESSTAT_SLAVE(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.DFTHED_WORK) THEN
            CALL DFTHED_SLAVE(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.DFT_SUSCEP_WORK) THEN
             CALL DFT_SUSCEP_SLAVE(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.NPETES2_WORK .OR.
     &            IPRTYP.EQ.PCMBSOL_WORK) THEN
            CALL J1INTS(WORK(1),MWORK,IPRTYP,IPRINT)
         ELSE IF (IPRTYP.EQ.J1XP_WORK) THEN
            CALL J1XS(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.J2XP_WORK) THEN
            CALL J2XS(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.DFT_MOMO_WORK) THEN
            CALL DFT_MOMO_SLAVE(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QM3_NSP_WORK) THEN
            CALL QM3_NSPS(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QM3LNO_WORK) THEN
            CALL QM3LNO_S(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QM3QRO_WORK) THEN
            CALL QM3QRO_S(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QM3FIRST_1_WORK) THEN
            CALL QM3FIRST_S1(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QM3FIRST_2_WORK) THEN
            CALL QM3FIRST_S2(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.PARQMMM__WORK) THEN
            CALL PARQMMM_S(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.MM_FIELD_1_WORK) THEN
            CALL MM_FIELD_S1(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.MM_FIELD_2_WORK) THEN
            CALL MM_FIELD_S2(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.MM_POLAR_CONTR_WORK) THEN
            CALL MM_POLAR_CONTR_S(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.MMITER_INDDIP_WORK) THEN
            CALL MMITER_INDDIP_S(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMLNO_1_WORK) THEN
            CALL QMMMLNO_S1(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMLNO_2_WORK) THEN
            CALL QMMMLNO_S2(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMQRO_1_WORK) THEN
            CALL QMMMQRO_S1(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMQRO_2_WORK) THEN
            CALL QMMMQRO_S2(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMFIRST_1_WORK) THEN
            CALL QMMMFIRST_S1(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMFIRST_2_WORK) THEN
            CALL QMMMFIRST_S2(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMFIRST_3_WORK) THEN
            CALL QMMMFIRST_S3(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMFIRST_4_WORK) THEN
            CALL QMMMFIRST_S4(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMB2_1_WORK) THEN
            CALL QMMMB2_S1(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMB2_2_WORK) THEN
            CALL QMMMB2_S2(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMB2_3_WORK) THEN
            CALL QMMMB2_S3(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.QMMMB2_4_WORK) THEN
            CALL QMMMB2_S4(WORK(1),MWORK,IPRINT)
         ELSE IF (IPRTYP.EQ.LUCITA_WORK) THEN
            call lucita_coworker_main(work(1),mwork,iprint)
            lucita_models_enabled = .true.
         ELSE IF (IPRTYP.EQ.MEP_WORK) THEN
            CALL MEP_SLAVE(WORK(1),MWORK)
         ELSE IF (IPRTYP == POLARIZABLE_EMBEDDING) THEN
            CALL PELIB_IFC_SLAVE(IPRINT)
         ELSE IF (IPRTYP == QFIT_WORK) THEN
            CALL QFITLIB_IFC_SLAVE(LUPRI, IPRINT)
#if defined(BUILD_GEN1INT)
C added by Bin Gao, May 12, 2012
         ELSE IF (IPRTYP.EQ.GEN1INT_INIT) THEN
            CALL gen1int_worker_init()
         ELSE IF (IPRTYP.EQ.GEN1INT_GET_INT) THEN
            CALL gen1int_worker_get_int(MWORK,WORK(1),LUPRI,IPRINT)
         ELSE IF (IPRTYP.EQ.GEN1INT_GET_EXPT) THEN
            CALL gen1int_worker_get_expt(MWORK,WORK(1),LUPRI,IPRINT)
         ELSE IF (IPRTYP.EQ.GEN1INT_GET_CUBE) THEN
            CALL gen1int_worker_get_cube(MWORK,WORK(1),LUPRI,IPRINT)
#endif
         ELSE IF (IPRTYP.EQ.PARA_SO_ERES) THEN
            CALL SOPPA_NODEDRIVER(work(1), mwork, iprint )
#ifdef MOD_CGTO_DIFF_ERI
         ! added by Bin Gao, Oct. 27, 2012
         ! cgto-diff-eri code to calculate arbitray order geometric derivatives
         ! of two-electron integrals
         ELSE IF (IPRTYP.EQ.CGTO_DIFF_ERI_INIT) THEN
            CALL unopt_geodiff_loop_worker(LUPRI,IPRINT)
#endif
         ELSE IF (IPRTYP.EQ.QMCMM_WORK) THEN
#ifdef ENABLE_VPOTDAMP
            CALL vpotdamped_slave()
#else
            call quit('VPOTDAMP not compiled in this version')
#endif

#if defined (HAS_PCMSOLVER)
         else if (iprtyp.eq.pcmsolver_npetes2_work) then
            call j1ints_pcm(work(1),mwork,iprtyp,iprint)
         else if (iprtyp.eq.pcmsolver_pcmbsol_work) then
            call j1ints_pcm(work(1),mwork,iprtyp,iprint)
#endif

         else if (IPRTYP .eq. CALL_FCKTRA_DISTRIBUTED ) THEN
            call FCKTRA_DISTRIBUTED_NODE(WORK(1),MWORK,IPRINT)
         else if (IPRTYP .eq. PAR_SRDFT_INTEGRATION ) THEN
            call SRDFT_PAR_NODE(WORK(1),MWORK,IPRINT)
         ELSE
            WRITE(LUPRI,'(/A,I5,A,I0)')
     &         '(DALTON_NODEDRIVER) ERROR on slave',mynum,
     &         ': Unknown calculation type request ',IPRTYP
            WRITE(*,'(/A,I5,A,I0)')
     &         '(DALTON_NODEDRIVER) ERROR on slave',mynum,
     &         ': Unknown calculation type request ',IPRTYP
            CALL QUIT('DALTON_NODEDRIVER: Unknown calculation type')
         END IF
C
         CALL newTIMER('this task')
         GO TO 100
      END IF ! IPRTYP .gt. 0

!     release memory
      if(allocated(work)) deallocate(work)
C
      IF (MYNUM .LE. 20) THEN
         CALL GETTIM(CEND,WEND)
         CTOT = CEND - CSTR
         WTOT = WEND - WSTR
C
         WRITE (LUPRI,'(/A,I10/)') 'Number of tasks performed:',N_TASKS
         CALL TIMTXT(' Total CPU  time used:',CTOT,LUPRI)
         CALL TIMTXT(' Total wall time used:',WTOT,LUPRI)
C
C        Stamp date and time and hostname to output
C
         CALL TSTAMP(' ',LUPRI)
      END IF
C
      CALL QEXIT('DALTON_NODEDRIVER')
      RETURN
      END
#endif

C  /* Deck dalton_parctl */
      SUBROUTINE DALTON_PARCTL(ITASK,IPRINT)
C
C 20-Oct-2019 Hans Joergen Aa. Jensen
C
C Called by master node to control parallel calculation.
C Can be used to send slaves to sleep and to wake them up.
C
C ITASK .gt. 0: wake slaves and get hold of them for task ITASK
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
C
      implicit none
      integer :: itask, iprint
C
#if defined (VAR_MPI)
#include "maxorb.h"
#include "infpar.h"
      INCLUDE 'mpif.h'
#include "mtags.h"

      integer :: NODE
      integer(kind=MPI_INTEGER_KIND), allocatable ::
     &   my_requests(:), my_statuses(:,:), IERR, NODTOT_mpi
      logical, save  :: first_call = .true.
C

      IF (NODTOT .EQ. 0) RETURN   ! MPI version of DALTON, but no slaves (i.e. sequential)

      if (first_call) then
         allocate ( my_requests(nodtot) )
         allocate ( my_statuses(MPI_STATUS_SIZE,nodtot) )
         first_call = .false.
      end if
      IF (ITASK .EQ. -1) THEN
C        go back from submenu to main menu via MPI_BCAST
!        CALL MPIXBCAST(IPRINT,1,'INTEGER',MASTER)
      ELSE
C        slave should be in main menu, ready to receive task
C        (we use point-to-point communication instead of mpi_bcast, so it can be probed with mpi_iprobe)
         CALL MPIXBCAST(ITASK,1,'INTEGER',MASTER)

         CALL MPIXBCAST(IPRINT,1,'INTEGER',MASTER)
      END IF

#else /* not VAR_MPI */

      CALL QUIT('DALTON_PARCTL called '//
     &   'but this is a sequential DALTON version !')

#endif /* VAR_MPI */
      RETURN
      END
C  /* Deck myMPI_sendname */
      SUBROUTINE myMPI_SENDNAME()
C
#if defined (VAR_MPI)
#include "implicit.h"
#include "priunit.h"
#include "maxorb.h"
#include "mtags.h"
C
#include "infpar.h"
C
C     Get name of my host machine
C
      CALL GETNAME(MYNAME)
C
C     Send name to master
C
      CALL MPIXSEND(MYNAME,20,'STRING',MASTER,MTAG8)
#endif
C
      RETURN
      END
C  /* Deck recvnames */
      SUBROUTINE RECVNAMES
C
#include "implicit.h"
#include "priunit.h"
#include "maxorb.h"
#include "mtags.h"
      CHARACTER NAME*20
#include "infpar.h"
C
C     Get my name
C
      CALL GETNAME(MYNAME)
      NODNAM(0) = MYNAME
C
C     Receive node names
C
#if defined (VAR_MPI)
      DO I = 1,NODTOT
         NWHO = -1
         CALL MPIXRECV(NAME,20 ,'STRING',NWHO,MTAG8)
         NODNAM(NWHO) = NAME
      END DO

      IF (IPRPAR.GT.0) THEN
         WRITE (LUPRI,'(3X,A,A)') ' Slaves are : ',NODNAM(1)
         WRITE (LUPRI,'(17X,A)') (NODNAM(I),I=2,NODTOT)
      END IF
#endif

      RETURN
      END
C  /* Deck sdtim */
      SUBROUTINE SDTIM(CPU1,WALL1,IPRINT)
C
C Used from common blocks:
C
C MXORB  : MXSHEL (for INFPAR)
C INFPAR : MASTER, MYNUM, NCODE
C
#include "implicit.h"
#include "maxorb.h"
#include "mtags.h"
      REAL*8 TMGARR(2)
#include "infpar.h"
C
      IF (IPRINT .GT. 3) CALL TITLER('Output from SDTIM','*',103)
C
      CALL GETTIM(CPU2,WALL2)
C
      TMGARR(1) = CPU2  - CPU1
      TMGARR(2) = WALL2 - WALL1
C
#if defined (VAR_MPI)
      CALL MPIXSEND(TMGARR,2 ,'DOUBLE',MASTER,MTAG8)
#endif
C
      RETURN
      END
C  /* Deck rvtim */
      SUBROUTINE RVTIM(NSTAT,CPUS,WALLS,NODNAM,NODTOT,IPRINT)
C
#include "implicit.h"
#include "priunit.h"
#include "mtags.h"
      CHARACTER*20 NAME, NODNAM(NODTOT)
      DIMENSION NSTAT(NODTOT),CPUS(NODTOT),WALLS(NODTOT)
      REAL*8 TMGARR(2)
C
      SAVE TSOFAR
      DATA TSOFAR/0.0D0/
C
      IF (IPRINT .GT. 3) CALL TITLER('Output from RVTIM','*',103)
C

      DO 100 I = 1,NODTOT
#if defined (VAR_MPI)
         NWHO = -1
         CALL MPIXRECV(TMGARR,2,'DOUBLE',NWHO,MTAG8)
#else
         NWHO = I
#endif
         CPUS(NWHO)   = TMGARR(1)
         WALLS(NWHO)  = TMGARR(2)
         TSOFAR = TSOFAR + CPUS(NWHO)
C
  100 CONTINUE
C
      IF (IPRINT .LE. 0) GOTO 9000
      IF (IPRINT .GT. 1) THEN
         CALL AROUND('Overall statistics for distribution of batches')
C
         WRITE(LUPRI,'(9X,5(A,4X))')   'Nodename',
     &                                 'Batches',
     &                                 'CPU time',
     &                                 'Wall time',
     &                                 'Efficiency'
         WRITE(LUPRI,'(9X,5(A,4X)/)')  '--------',
     &                                 '-------',
     &                                 '--------',
     &                                 '---------',
     &                                 '----------'
C
         DO 200 NWHO = 1, NODTOT
            IF (WALLS(NWHO) .NE. 0.0D0) THEN
               EFFI = (CPUS(NWHO)/WALLS(NWHO))*100
            ELSE
               EFFI = 0.0D0
            END IF
            WRITE(LUPRI,'(9X,A10,I7,6X,F8.2,5X,F8.2,6X,F6.2)')
     &           NODNAM(NWHO),NSTAT(NWHO),CPUS(NWHO),WALLS(NWHO),EFFI
 200     CONTINUE
      END IF
C
      IMINS  = INT(NINT(TSOFAR)/60)
      IHOURS = INT(IMINS/60)
      IMINS  = IMINS - 60*IHOURS
      ISECS  = NINT(TSOFAR) - 3600*IHOURS - 60*IMINS
C
      WRITE(LUPRI,'(/A,I5.2,A,I2.2,A,I2.2)')
     &     ' Total CPU  time used in NODES  so far   :',
     &     IHOURS,':',IMINS,':',ISECS
      CALL FLSHFO(LUPRI)
C
 9000 RETURN
      END
C  /* Deck pardrv */
      SUBROUTINE PARDRV(FMAT,DMAT,NDMAT,ISYMDM,IFCTYP,WORK,NSTAT,
     &                  HESSEE,LWORK,ITYPE,MAXDIF,IATOM,NODV,NOPV,
     &                  NOCONT,TKTIME,RETUR,IPRINT,IPRTYP,
     &                  ICEDIF,IFTHRS,GABRAO,DMRAO,DMRSO,DINTSKP,GENCTR)
C
#include "implicit.h"
#include "priunit.h"
#include "maxorb.h"
#include "mtags.h"
      LOGICAL NODV,NOPV,NOCONT,RETUR,TKTIME,GENCTR
      DIMENSION FMAT(*),DMAT(*),ISYMDM(*),IFCTYP(*),WORK(LWORK),
     &          NSTAT(NODTOT), HESSEE(*)
CTROND
      DIMENSION GABRAO(*),DMRAO(*),DMRSO(*),DINTSKP(*)
CTROND
C
C Used from common blocks
C
C MXORB  : MXSHEL (for INFPAR)
C INFPAR : MASTER, NODTOT, IPRPAR,  NCODE, DBG
C iprtyp.h : HER_WORK, ERI_WORK
C GNRINF : BASDIR, LENBAS
C
#include "infpar.h"
#include "iprtyp.h"
#include "gnrinf.h"
      DATA TOTWAL /0.0D0/
      SAVE TOTWAL
C
      CALL QENTER('PARDRV')
C
!     IPRPAR = 11
      IPRINT = MAX(IPRINT,IPRPAR)
C
      IF (IPRPAR .GT. 0) CALL GETTIM(CPU1,WALL1)
C
      IF (INFPAR_DEBUG) THEN
         IPRNOD = IPRINT
      ELSE
         IPRNOD = 0
      END IF
      IPRNOD = MAX(IPRNOD,IPRPAR_DEBUG)
      IF (IPRINT .GT. 3) THEN
         CALL TITLER('Output from PARDRV','*',103)
         WRITE(LUPRI,'(/A,2I5)')
     &      'Parallel types IPRTYP and ITYPE are',IPRTYP,ITYPE,
     &      'Print level on nodes is',IPRNOD
      END IF
C
C     Tell nodes whether this is an ERI or HERMIT run. Send IPRNOD
C
#if defined (VAR_MPI)
      CALL DALTON_PARCTL(IPRTYP,IPRNOD)
#endif
      IF (IPRTYP.EQ.HER_WORK) THEN
         if (iprint .gt. 3)
     &      write (lupri,*) 'Calling parallel HERMIT routines.'
         CALL HER_PARDRV(FMAT,DMAT,HESSEE,NDMAT,ISYMDM,IFCTYP,NSTAT,
     &                   WORK,LWORK,ITYPE,MAXDIF,IATOM,NODV,
     &                   NOPV,NOCONT,TKTIME,RETUR,IPRINT,
     &                   ICEDIF,IFTHRS,GABRAO,DMRAO,DMRSO,
     &                   DINTSKP,RELCAL,GENCTR)
      ELSE IF (IPRTYP.EQ.ERI_WORK) THEN
         if (iprint .gt. 3)
     &      write (lupri,*) 'Calling parallel ERI routines.'
         CALL ERI_PARDRV(FMAT,DMAT,NDMAT,ISYMDM,IFCTYP,NSTAT,
     &                   WORK,LWORK,IPRINT)
      ELSE
         write (lupri,*) 'PARDRV: Invalid IPRTYP = ',IPRTYP
         CALL QUIT('PARDRV: Invalid IPRTYP here')
      END IF
C
      KCPUS  = 1
      KWALLS = KCPUS  + NODTOT
      KLAST  = KWALLS + NODTOT
      IF (KLAST .GT. LWORK)
     &   CALL STOPIT('PARDRV','RVTIM',KLAST,LWORK)
C
      CALL RVTIM(NSTAT,WORK(KCPUS),WORK(KWALLS),NODNAM(1),NODTOT,IPRINT)
C
      IF (IPRPAR .GT. 0) THEN
         CALL GETTIM(CPU2,WALL2)
         CPU    = CPU2 - CPU1
         WALL   = WALL2 - WALL1
         TOTWAL = TOTWAL + WALL
C
         IMINS  = INT(NINT(TOTWAL)/60)
         IHOURS = INT(IMINS/60)
         IMINS  = IMINS - 60*IHOURS
         ISECS  = NINT(TOTWAL) - 3600*IHOURS - 60*IMINS
C
         WRITE(LUPRI,'(A,I5.2,A,I2.2,A,I2.2)')
     &     ' Total wall time used in PARDRV so far   :',
     &      IHOURS,':',IMINS,':',ISECS
         IF (IPRPAR .GT. 2) THEN
            WRITE(LUPRI,'(A,F11.2,/A,F11.2)')
     &        ' CPU  time used in PARDRV last iteration :',
     &          CPU,
     &        ' Wall time used in PARDRV last iteration :',
     &          WALL
         END IF
      END IF
C
      CALL QEXIT('PARDRV')
      RETURN
      END
! --- end of main/dalpar.F ---
